home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / bcomp / scan.scm < prev    next >
Text File  |  1995-10-13  |  8KB  |  292 lines
  1. ; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3. ; Added really-scan-structures, which gives you noise control.
  4. ;     -Olin 6/95.
  5.  
  6.  
  7.  
  8. ; Macro-expand and process top-level forms.
  9. ;
  10. ; Main entry points are:
  11. ;    scan-forms (suitable for use by eval)
  12. ;    scan-file (suitable for use by load or compile-file)
  13. ; These both return lists of nodes.
  14. ; DEFINE and DEFINE-SYNTAX forms cause side effects to the package.
  15. ; Forms are macro-expanded as necessary in order to locate all definitions.
  16. ;
  17. ; Entry points supporting the package system are:
  18. ;    scan-structures
  19. ;    scan-package
  20. ; These both return lists of (filename . node-list).
  21. ;
  22. ; Also defined here is SCAN-BODY, which scans a lambda-body for
  23. ; internal definitions.  This is an independent mechanism.
  24.  
  25.  
  26. (define $note-file-package (make-fluid list)) ;Hook
  27.  
  28.  
  29. ; Scan a set of forms for definitions.
  30.  
  31. (define (scan-forms forms p filename . env-option)
  32.   (let ((env (if (null? env-option)
  33.          (package->environment p)
  34.          (car env-option))))
  35.     (if filename ((fluid $note-file-package) filename p))
  36.     (scan-form-list forms p (bind-source-file-name filename env))))
  37.  
  38. ; Read a file, scanning it for definitions.
  39.  
  40. (define (scan-file pathname p . env-option)
  41.   (apply really-scan-file pathname p (current-output-port) env-option))
  42.  
  43. (define (really-scan-file pathname p noise . env-option)
  44.   (let* ((env (if (null? env-option)
  45.           (package->environment p)
  46.           (car env-option)))
  47.      (filename (namestring pathname #f *scheme-file-type*))
  48.      (truename (translate filename)))
  49.     (call-with-input-file truename
  50.       (lambda (port)
  51.     (if filename ((fluid $note-file-package) filename p))
  52.     (let ((env (bind-source-file-name filename env))
  53.           (reader (environment-reader env)))
  54.       (cond (noise (display truename noise)
  55.                (force-output noise)))
  56.       (let ((result (let recur ()
  57.               (let ((form (read port)))
  58.                 (if (eof-object? form)
  59.                 '()
  60.                 (append (scan-form form p env)
  61.                     (recur)))))))
  62.         (cond (noise (display #\space noise)
  63.              (force-output noise)))
  64.         result))))))
  65.  
  66.  
  67. ; --------------------
  68. ; Process a list of forms.
  69.  
  70. (define (scan-form-list forms p env)
  71.   (let loop ((forms forms))
  72.     (if (null? forms)
  73.     '()
  74.     ;; Force order of evaluation
  75.     (let ((scanned-forms (scan-form (car forms) p env)))
  76.       (append scanned-forms
  77.           (loop (cdr forms)))))))
  78.  
  79. ; Process a single top-level form, returning a list of nodes.
  80.  
  81. (define scan-form
  82.   (let ((begin-node? (node-predicate 'begin syntax-type)))
  83.     (lambda (form p env)
  84.       (let ((node (classify form env)))
  85.     (cond ((begin-node? node)
  86.            (scan-form-list (cdr (node-form node)) p env))
  87.           ((define-node? node)
  88.            (let ((form (node-form node)))
  89.          (package-define! p (cadr form) usual-variable-type)
  90.          (list node)))
  91.           ((define-syntax-node? node)
  92.            (process-define-syntax (node-form node) p env)
  93.            (list node))
  94.           (else
  95.            (list node)))))))
  96.  
  97.  
  98. ; Process a single (define-syntax ...) form
  99.  
  100. (define (process-define-syntax form p env)
  101.   (let ((name (cadr form))
  102.     (source (caddr form)))
  103.     (package-define! p name
  104.              (process-syntax (if (null? (cdddr form))
  105.                      source
  106.                      `(cons ,source ',(cadddr form))) ;foo
  107.                      env name p))))
  108.  
  109. ; Package system stuff
  110.  
  111.  
  112. ; Utility for compile-structures and ensure-loaded.
  113.  
  114. (define (scan-structures structs process-package? package-action)
  115.   (really-scan-structures structs (current-output-port)
  116.               process-package? package-action))
  117.  
  118. (define (really-scan-structures structs noise process-package? package-action)
  119.   (let ((p-seen '())
  120.     (s-seen '()))
  121.     (letrec ((recur (lambda (s)
  122.               (if (not (memq s s-seen))
  123.               (begin
  124.                 (set! s-seen (cons s s-seen))
  125.                 (let ((p (structure-package s)))
  126.                   (if (and (not (memq p p-seen))
  127.                        (process-package? p))
  128.                   (begin
  129.                     (cond (noise
  130.                        (display "[" noise)
  131.                        (write (structure-name s) noise)
  132.                        (newline noise)))
  133.                     (set! p-seen (cons p p-seen))
  134.                     (for-each recur (package-opens p))
  135.                     (for-each (lambda (name+struct)
  136.                         (recur (cdr name+struct)))
  137.                           (package-accesses p))
  138.                     (let ((stuff (really-scan-package p noise)))
  139.                       (really-noting-undefined-variables
  140.                         p noise
  141.                         (lambda () (package-action stuff p))))
  142.                     (check-structure s)
  143.                     (cond (noise
  144.                        (display "]" noise)
  145.                        (newline noise))))
  146.                   (check-structure s))))))))
  147.       (for-each recur structs))))
  148.  
  149.  
  150. ; Returns a list of pairs (file . (node1 node2 ...)).
  151. (define (scan-package p . env-option)
  152.   (apply really-scan-package p (current-output-port) env-option))
  153.  
  154. (define (really-scan-package p noise . env-option)
  155.   (let* ((env (if (null? env-option)
  156.           (package->environment p)
  157.           (car env-option)))
  158.      (stuff '())
  159.      (config-file (package-file-name p))
  160.      (dir (if config-file
  161.           (file-name-directory config-file)
  162.           #f)))
  163.  
  164.     (for-each (lambda (clause)
  165.         (case (car clause)
  166.           ((files)
  167.            (for-each (lambda (file)
  168.                    (let ((file (namestring file
  169.                                dir
  170.                                *scheme-file-type*)))
  171.                  (set! stuff
  172.                        (cons (cons file
  173.                            (really-scan-file file p
  174.                                      noise env))
  175.                          stuff))))
  176.                  (cdr clause)))
  177.           ((begin)
  178.            (set! stuff
  179.              (cons (cons config-file
  180.                      ;; We could pass config-file here, but
  181.                      ;; that screws up the emacs interface
  182.                      (scan-forms (cdr clause) p #f env))
  183.                    stuff)))
  184.           ((integrate)
  185.            (set-package-integrate?! p (or (null? (cdr clause))
  186.                           (cadr clause))))
  187.           ((optimize))
  188.           ((define-all-operators)
  189.            (set! stuff
  190.              (cons (define-all-operators p) stuff)))
  191.           ((usual-transforms)
  192.            (initialize-usual-transforms! p (cdr clause)))
  193.           (else
  194.            (error "unrecognized define-structure keyword"
  195.               clause))))
  196.           (package-clauses p))
  197.  
  198.     (optimize (reverse stuff) p)))
  199.  
  200. (define (optimize stuff p)
  201.   (if (package-integrate? p)
  202.       (let ((optimizers
  203.          (apply append
  204.             (map cdr (filter (lambda (clause)
  205.                        (eq? (car clause) 'optimize))
  206.                      (package-clauses p))))))    
  207.     (if (null? optimizers)
  208.         stuff
  209.         (let* ((names (if (memq 'expand optimizers)
  210.                   optimizers
  211.                   (cons 'expand optimizers)))
  212.            (passes (map get-optimizer names)))
  213.           (if (every (lambda (x) x) passes)
  214.           (reduce (lambda (pass stuff)
  215.                 (pass stuff p))
  216.               stuff
  217.               (reverse passes))
  218.           (begin (signal 'note
  219.                  "optional optimization passes not invoked"
  220.                  optimizers)
  221.              stuff)))))
  222.       stuff))
  223.  
  224.  
  225. (define (check-structure s)
  226.   (let ((undefined '()))
  227.     (for-each-export
  228.          (lambda (name want-type binding)
  229.        (if (binding? binding)
  230.            (let ((have-type (binding-type binding)))
  231.          (if (not (compatible-types? have-type want-type))
  232.              (warn "Type in interface doesn't match binding"
  233.                name
  234.                `(binding: ,(type->sexp have-type #t))
  235.                `(interface: ,(type->sexp want-type #t))
  236.                s)))
  237.            (set! undefined (cons name undefined))))
  238.      s)
  239.     (if (not (null? undefined))
  240.     (warn "Structure has undefined exports"
  241.           s
  242.           undefined))))
  243.  
  244.  
  245. ; The usual transforms
  246.  
  247. (define (initialize-usual-transforms! p names)
  248.   (for-each (lambda (name)
  249.           (package-define! p name
  250.                    (make-transform (usual-transform name)
  251.                            p
  252.                            syntax-type
  253.                            `(usual-transform ',name)
  254.                            name)))
  255.         names))
  256.  
  257. ; Initialization for built-in integrations.
  258.  
  259. (define (define-all-operators p)
  260.   (let ((procs '()))
  261.     (table-walk (lambda (name op)
  262.           (let ((type (operator-type op)))
  263.             (if (not (or (eq? type syntax-type)
  264.                  (memq type '(leaf internal))))
  265.             (set! procs (cons name procs)))))
  266.         operators-table)
  267.     (let ((nodes (scan-forms (map make-define-primitive-node procs)
  268.                  p #f)))
  269.       (table-walk (lambda (name op)
  270.             (if (not (eq? (operator-type op) 'leaf))
  271.             (package-define! p name op)))
  272.           operators-table)
  273.       (cons #f nodes))))
  274.  
  275.  
  276. (define make-define-primitive-node
  277.   (let ((operator/define (get-operator 'define syntax-type))
  278.     (operator/primitive-procedure
  279.      (get-operator 'primitive-procedure syntax-type)))
  280.     (lambda (name)
  281.       (make-node operator/define
  282.          `(define ,name
  283.             ,(make-node operator/primitive-procedure
  284.                 `(primitive-procedure ,name)))))))
  285.  
  286. ; Optimizers
  287.  
  288. (define optimizers-table (make-table))
  289. (define (get-optimizer name)
  290.   (table-ref optimizers-table name))
  291. (define (set-optimizer! name opt) (table-set! optimizers-table name opt))
  292.